PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/tracerp.com/TRACE.PAS

Pascal/Delphi Source File | 1989-05-12 | 16.7 KB | 492 lines

{═══════════════════════════════ TRACE.PAS ═══════════════════════════════}
{                 Copyright (c) 1989  Richard W. Prescott                 }
{ This Unit contains the assembly code for the basic interrupt routine,   }
{ which is installed by calling TraceOn and which is detached by calling  }
{ TraceOff or TRelease.  If the interrupt routine is still active upon    }
{ normal or abnormal (e.g. Run-Time Error) program termination, it is     }
{ detached automatically by the Unit Exit Code.  The original interrupt   }
{ vector is stored in the current Code segment to simplify chaining to    }
{ the original interrupt routine in TRelease.  The assembly code within   }
{ the Procedure THook traps each Interrupt $01 from the subject Code      }
{ segment and issues a FAR Jmp via the Pointer variable PascalCode.       }
{ Return to the label "Resume" is accomplished via the directive TReturn. }
{ PascalCode must be initialized by TraceOn to point to an ordinary (not  }
{ interrupt) Procedure which will provide the desired Trace routine.      }
{═════════════════════════════════════════════════════════════════════════}
{ This Unit was compiled and assembled using Turbo Pascal Version 5.0     }
{ and TP&Asm Version 2.0.  TP&Asm provides an integrated compile-time     }
{ assembler within the Turbo development environment (and the command     }
{ line compiler TPC), resulting in an ASSEMBLY Development Environment    }
{ which is identical to your PASCAL Development Environment.              }
{                                                                         }
{  TP&Asm Version 2.0 is available from me for $49 plus $3 P&H.  Please   }
{             see the file TRACE.DOC for further information.             }
{═════════════════════════════════════════════════════════════════════════}

Unit TRACE;
{$D-}

interface

{- Public Variables -}

TYPE
  UserRegs = RECORD
    CASE INTEGER OF
      0: (Ax,Bx,Cx,Dx,Si,Ds,Di,Es,Bp,Ip,Cs,Flags: WORD);
      1: (Al,Ah,Bl,Bh,Cl,Ch,Dl,Dh : BYTE);
  END; {UserRegs}

VAR
  TExitSp,UserSP,UserSS: WORD;
  User: ^UserRegs absolute UserSP;


CONST
  PascalCode: Pointer = Nil;


{- Public Procedures -}

PROCEDURE TraceOn(CodePtr: POINTER);
PROCEDURE TraceOff;
PROCEDURE TRelease;


{- Inline Directives -}

{════════════════════════════════ TReturn ════════════════════════════════}
{ Restore Stack Pointer to its value on entry to the Pascal service       }
{ routine, and issue a Far Return.  This technique permits use of TReturn }
{ from within nested sub-procedures.  User registers (User^.Ax, etc) may  }
{ be inspected but should not be modified.                                }
{════════════════════════════════ TReturn ════════════════════════════════}
PROCEDURE TReturn; {- Inline Directive -}
Assembly
  Mov Sp,TExitSp  ; Restore Stack Pointer
  Retf            ;  .. and return to label "Resume" within THook
END; {- TReturn -}

{════════════════════════════════ ReadKey ════════════════════════════════}
{ Read keyboard without echo to screen.  (Similar to ReadKey in CRT Unit) }
{ Returns the same character that would be returned by CRT Unit ReadKey,  }
{ except that ANSI.SYS macros are expanded and Ctrl-C and Ctrl-Break are  }
{ treated as characters rather than as user break requests.  (Provided    }
{ here so that DEMOTRC.PAS will not require the CRT unit).                }
{════════════════════════════════ ReadKey ════════════════════════════════}
FUNCTION ReadKey:  CHAR; {- Inline Directive -}
Assembly
  Mov Ah,7
  Int 21h
End;


implementation

{- Private variables -}
CONST
  TurboDSS: WORD = 0;
  SigString: STRING[5] =
        {$IFDEF VER40}   'VER40';   {$ELSE}   'VER50';   {$ENDIF}

  TraceErrorAddr: Pointer = Nil;

  InstallError0: STRING[45] = 'Cannot nest TraceOn Calls (TRACE was Active)$';
  InstallError1: STRING[45] = 'Trace Code Pointer must point to a Procedure$';
  InstallError2: STRING[44] = 'Trace Procedure must contain a TReturn Call$';
  InstallError3: STRING[45] = 'Trace Code must reside in CS of Subject Code$';
  ReleaseError : STRING[47] = 'Cannot TRelease outside active TRACE procedure$';
  PressAKey: STRING[21] = #13#10'Press any key ... $';

  PasTraceExit:  WORD = 0;
  PasTraceEntry: WORD = 0;

  TraceFlag  = $0100;
  TraceClear = $FEFF;


{════════════════════════════════ CsData ═════════════════════════════════}
{ The CSDATA construct is used to store data in the current Code Segment. }
{ The original interrupt address Int01Vec must be stored in this Code     }
{ Segment to allow Chaining to the original interrupt routine with all of }
{ the User Registers intact.  The Word TraceCs is stored in the Code      }
{ Segment so that it can be inspected before restoring the Turbo DSeg.    }
{ CsData Variables are available throughout the current Unit.             }
{════════════════════════════════ CsData ═════════════════════════════════}
CSDATA
  Int01Vec Dd 0
  Int03Vec Dd 0
  TInt1BEntry Dd 0:01504
  TraceCS Dw 0
  TraceSP Dw 0
  TraceBP Dw 0
END; {CsData}


{═════════════════════════════════ THook ═════════════════════════════════}
{ This is the assembly portion of the interrupt service routine.  First   }
{ check that the interrupted code was executing in the designated Trace   }
{ CSeg, and if not, issue an immediate return from interrupt.  This will  }
{ insure that we may reliably call any Pascal Procedure or Function       }
{ (including those which use DOS services) within the Pascal Code of the  }
{ Trace routine.  If the CSeg checks out, save registers, restore Ds,     }
{ "Push" the Cs:Ip of the label "Resume" onto the stack, and issue an     }
{ indirect Jmp to the address stored in the Pointer PascalCode.  Within   }
{ the Pascal Trace routine, the interrupted program registers may be      }
{ inspected via the User record, eg "InChar := User^.Ax;"                 }
{ The Pascal code for the Interrupt Service must end with TReturn.        }
{═════════════════════════════════ THook ═════════════════════════════════}
PROCEDURE THook; Forward;
Internal Hook;
;- Use INTERNAL to eliminate standard Pascal Startup Code

CODE Segment

THook PROC NEAR

  Push Bp
  Mov Bp,Sp ;- Flags at [Bp+6],  CS at [Bp+4],  IP at [Bp+2],  BP at [Bp+0]

  Push Ax
  Mov Ax,[Bp+4]          ; Cs of interrupted program
  Cmp Ax,TraceCS         ; Wake up only for Trace Cs
  jE SaveRegs
  Pop Ax,Bp              ; Else restore Regs and
  Iret                   ;  return to interrupted program

SaveRegs:
  Pop Ax
  Push Es,Di,Ds,Si,Dx,Cx,Bx,Ax

  Mov Ax,SEG Data
  Mov Ds,Ax              ; Restore Our Ds

WakeUp:
  Mov UserSS,Ss          ; Save User Stack Ss:Sp in Our Ds
  Mov UserSP,Sp          ;  (other registers stored on User Stack)

  Push Cs                ; "Push" Cs:Ip of label "Resume"
  Call TrapProcessing    ;   onto stack

Resume:                  ; Return here from Pascal Trace Routine (TReturn)
  Cmp TraceCs,0          ; If TraceOff called within Pascal Trace routine,
  IF Z And [Bp+6],TraceClear   ;- must clear trace flag here

  Pop Ax,Bx,Cx,Dx,Si,Ds,Di,Es,Bp   ;- Restore user registers
  Iret                   ; and return to interrupted program

TrapProcessing:
  Mov TExitSp,Sp
  Push TraceBp           ; Push Parent Bp onto stack above a
  Push Ax                ;  fake return Ip.  Permits access to parent
                         ;  stack frame if PascalCode is a local Proc
  Jmp PascalCode         ; Jmp via pointer to Pascal Service Routine

THook ENDP
CODE ENDS
END {- Internal Hook -}


{═════════════════════════════ SignalRunError ════════════════════════════}
{ On entry Ds:Dx points to a '$'-terminated error message and DWORD PTR   }
{ [Bp+2] contains the address of the instruction following an invalid     }
{ TraceOn/TRelease Call.  Adjust the segment value to the relative        }
{ segment format used for Run-Time errors, save into TraceErrorAddr, and  }
{ then issue a Halt(204) to set ExitCode and invoke the exit procedures.  }
{═════════════════════════════ SignalRunError ════════════════════════════}
PROCEDURE SignalRunError;
{$S-} BEGIN {$S+}       {- Don't generate Stack check code -}
 Assembly
  Pop Bp                 ; Restore Bp to its value on entry
  Mov Ah,09              ; Display Error
  Int 21h
  Lea Dx,PressAKey+1
  Mov Ah,09              ; Display "Press any key ..."
  Int 21h
  Xor Ah,Ah
  Int 16h                ; wait for key

  Mov Ax,[Bp+2]          ; User Ip following invalid TraceOn/TRelease Call
  Mov W TraceErrorAddr,Ax

  Mov Ax,[Bp+4]          ; User Cs of invalid TraceOn/TRelease Call
  Sub Ax,PrefixSeg
  Sub Ax,$10
 Pas {$IFDEF Ver40}
 ;- For the Version 4.0 IDE only, adjust reported error CSeg
  Cmp TurboDSS,0
  jZ NoIDE40
  Mov Es,TurboDSS
  Es Mov Es,[$4428]      ; Point Es to PROGRAM TPU in Memory
  Mov Ax,[Bp+4]          ; User Cs
  Es Sub Ax,[$0022]      ; Subtract Runtime Code Starting Segment
 NoIDE40:
 Pas {$ENDIF}

  Mov W TraceErrorAddr+2,Ax
 END; {Assembly}

  Halt(204);            {- Signal "Invalid Pointer Operation" -}

END; {PROCEDURE SignalRunError}


{════════════════════════════════ TraceOn ════════════════════════════════}
{ Check for valid Trace procedure at CodePtr and if necessary signal a    }
{ Run-Time error.  Otherwise, save and install a new Interrupt 01 vecter, }
{ set PascalCode := CodePtr, and adjust stack contents to permit use of   }
{ Iret to return to the subject code with the hardware trace flag on.     }
{════════════════════════════════ TraceOn ════════════════════════════════}
PROCEDURE TraceOn(CodePtr: POINTER);
BEGIN
 Assembly

  Lea Dx,InstallError0+1
  Cmp TraceCS,0          ; If TRACE is active, don't install
  jNE Error              ; 'Cannot nest TraceOn Calls (TRACE was Active)'

  Cld                    ; Scan forward
  Les Di,CodePtr

  Mov Al,$89             ; search for 89 EC 5D, standard Proc Exit
  Mov Cx,$FFFF
  Lea Dx,InstallError1+1
L1:
  RepNE ScasB
  jNE Error              ; 'Trace Code Pointer must point to a Procedure'
  Es Cmp W [Di],$5DEC
  jNZ L1
  Mov PasTraceExit,Di    ; Found Trace Proc Exit, save offset

  Les Di,CodePtr         ; Restore CodePtr Es:Di
  Mov PasTraceEntry,Di   ; Save offset of Trace Proc Entry

  Mov Al,$8B             ; search for 8B 26 XX XX CB  (TReturn)
  Not Cx                 ; expect to find at lower address than Proc Exit
  Lea Dx,InstallError2+1
L2:
  RepNE ScasB
  jNE Error              ; 'Trace Procedure must contain a TReturn Call'
  Es Cmp B [Di],$26
  jNZ L2
  Es Cmp B [Di+3],$CB
  jNZ L2

  Les Di,CodePtr         ; Restore CodePtr Es:Di

  Mov Ax,Es
  Mov Dx,Cs
  Cmp Ax,Dx
  jE Install             ; Allow Predefined Trace Procedures in this Unit
  Cmp Ax,[Bp+4]
  jE Install             ; Allow Trace Procedures in CS of Subject Code
  Lea Dx,InstallError3+1
  Jmp Error              ; 'Trace Code must reside in CS of Subject Code'

Install:
  Mov W PascalCode,Di
  Mov W PascalCode+2,Es  ; PascalCode := CodePtr;

;- Save & Install new interrupt

  Mov Ax,03503           ; Get Interrupt into Es:Bx
  Int 021                ;  (Stored in Code Seg to allow Chaining)
  Mov W Int03Vec,Bx
  Mov W Int03Vec+2,Es

  Mov Ax,03501           ; Get Interrupt into Es:Bx
  Int 021                ;  (Stored in Code Seg to allow Chaining)
  Mov W Int01Vec,Bx      ; This Assembly Reference will link in CSDATA
  Mov W Int01Vec+2,Es

  Mov Ax,02501           ; Set Interrupt to Ds:Dx
  Push Ds,Cs             ; Save DSeg,
  Pop Ds                 ;  point Ds to CSeg
  Mov Dx,Offset THook    ; This Assembly Reference will Link in THook
  Int 021
  Pop Ds                 ; Restore Ds to DSeg

  Pop Bp                 ; Restore Bp Pushed in standard Proc entry
  Mov TraceBp,Bp         ; Save Parent Bp for use in local Trace Procs
  Pop Bx,TraceCS         ; Save Ip in Bx, Set TraceCS
  PushF
  Pop Ax
  Or Ax,TraceFlag        ; Set-up for Iret with TraceFlag enabled
  Push Ax,TraceCS,Bx     ; Flags at [Sp+4], CS at [Sp+2], IP at [Sp+0]
  Iret                   ; NORMAL EXIT

Error:                   ; ABNORMAL EXIT
  Call SignalRunError    ; Display Run-Time Error and Halt

 END; {Assembly}

END; {PROCEDURE TraceOn; }



{═══════════════════════════════ TraceOff ════════════════════════════════}
{ Restore the interrupt $01 vector to the value saved during TraceOn,     }
{ clear the TraceFlag bit in the current flags, and clear TraceCs.  Can   }
{ be called either from the sublect code or from within the Pascal Trace  }
{ procedure.  In the latter case the current flags will not affect those  }
{ of the subject program, so if TraceCs = 0 after TReturn, the TraceFlag  }
{ bit of the subject program flags will be cleared at "Resume:" in THook. }
{═══════════════════════════════ TraceOff ════════════════════════════════}
PROCEDURE TraceOff;
{$S-} BEGIN {$S+}   {- Don't generate Stack check code -}
 Assembly

  PushF
  Pop Ax
  And Ax,TraceClear      ; Clear TraceFlag bit in current flags
  Push Ax
  PopF

  Mov Ax,02501           ; Set Interrupt to Ds:Dx
  Push Ds
  Lds Dx,Int01Vec        ; Load Ds:Dx with saved value
  Cmp TraceCS,0          ; If Trace was active,
  IF NE Int 021          ;  restore interrupt vector
  Pop Ds
  Mov TraceCS,0          ; Clear TraceCS

 END; {Assembly}
END; {TraceOff}


{═══════════════════════════════ TRelease ════════════════════════════════}
{ Release control to IDE or external debugger.  External debuggers will   }
{ trap at the next assembly instruction in the subject module.  The IDE   }
{ debugger will trap the next Pascal instruction in the subject module.   }
{ Must be called from within an active Trace routine.                     }
{═══════════════════════════════ TRelease ════════════════════════════════}
PROCEDURE TRelease;
Label Error;
BEGIN

 Assembly

  Push TraceCS
  Call TraceOff          ; Restore Int01 Vector and clear TraceCs
  Pop Ax                 ; TraceCs value before it was cleared

  Lea Dx,ReleaseError+1
  Cmp Ax,[Bp+4]          ; User Cs of TRelease Call
  jNE Error              ; 'Cannot TRelease outside active TRACE procedure'
  Mov Ax,[Bp+2]          ; User Ip of TRelease Call
  Cmp Ax,PasTraceEntry
  jB Error
  Cmp Ax,PasTraceExit
  jA Error

  Mov Sp,TExitSp         ; Restore Stack Pointer in
  Add Sp,4               ;  preparation for popping User Regs

 END; {Assembly}

{$IFDEF VER50}

 IF TurboDSS <> 0 THEN Assembly

  Mov Es,W Int01Vec+2    ; Turbo InitCS
  Es Mov B[06D8],0

  Mov W TInt1BEntry+2,Es
  Mov W TInt1BEntry,01504
  PushF
  Call TInt1BEntry       ; Turbo 5.0 executes this during a user CBreak

  Es Mov B[06D9],0
  Xor Ax,Ax
  Mov Es,Ax
  Es And B[0471],07F

  Mov W Int01Vec,01537   ; v5 IDE entry point following ^Break

 END; {IF TurboDSS <> 0 THEN Assembly}

{$ENDIF}

 Assembly

  Pop Ax,Bx,Cx,Dx,Si,Ds,Di,Es,Bp  ; Restore user registers

  Jmp Int01Vec           ; Chain to original Int01 or IDE ^Break entry point

Error:
  Call SignalRunError

 END; {Assembly}

END; {PROCEDURE TRelease}



{═════════════════════════════════ TExit ═════════════════════════════════}
{ Unit Exit Procedure to automatically detach interrupt system and force  }
{ correct Run-Time error address for invalid TraceOn or TRelease Calls.   }
{═════════════════════════════════ TExit ═════════════════════════════════}
VAR   NextExit: POINTER;
{$F+} PROCEDURE TExit; {$F-}    {- Exit Procedures must use Far Model -}
{$S-} BEGIN {$S+}               {- Don't generate Stack check code -}
 TraceOff;
 ExitProc := NextExit;
 IF ErrorAddr = Nil THEN
  ErrorAddr:= TraceErrorAddr;   {- Nil if no error -}
END; {TExit}


{═════════════════════════════ Initialiation ═════════════════════════════}
{ Install Unit Exit procedure and automatically detect version 4.0 or     }
{ 5.0 Integrated Development Environment.  If found, set TurboDSS to the  }
{ IDE's Data/Stack segment.                                               }
{═════════════════════════════ Initialiation ═════════════════════════════}
BEGIN
  NextExit := ExitProc;
  ExitProc := @TExit;       {- Restore Interrupt 01 on Exit -}

{- initialization code -}
 Assembly
  Mov TurboDSS,0
  Cld
 Pas {$IFDEF VER40}
  Mov Cx,Cs
  Mov Ax,'yp'
 Pas {$ELSE}
  Mov Cx,PrefixSeg
  Mov Ax,'bA'
 Pas {$ENDIF}

 L0:
  jCXZ NoIDE
  Xor Di,Di
  Mov Es,Cx
  ScaSW
  LoopNE L0

 CheckSig:

 Pas {$IFDEF VER40}
  Mov Es,Cx      ; this effectively decrements Es
  Mov Di,$0FE2   ; v4 DSS offset of #05'VER40'
 Pas {$ELSE}
  Mov Di,$40C8   ; v5 DSS offset of #05'VER50'
 Pas {$ENDIF}

  Lea Si,SigString
  Push Cx
  Mov Cx,6
  RepE CmpSB
  Pop Cx
  jNE L0

 Found:
  Mov TurboDSS,Es

 NoIDE:

 END; {Assembly}

END.